home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / sources2 / Runtime (.scm & .s) / _eval.scm < prev    next >
Encoding:
Text File  |  1992-12-17  |  81.0 KB  |  1,910 lines  |  [TEXT/gamI]
  1.  "File not found")))
  2.  
  3.     (ct-error-syntax "Filename expected")))
  4.  
  5. ;------------------------------------------------------------------------------
  6.  
  7. ; Compiler's main entry
  8.  
  9. (define (##compile src frames)
  10.   (let ((cte (##make-cte frames)) (tail? #t))
  11.     (gen ##gen-top
  12.       frames
  13.       (##comp-top (##cte-push-frame cte (##list (self-var))) src tail?))))
  14.  
  15. (define (##comp-top cte src tail?)
  16.   (let ((src (##touch-list src)))
  17.     (cond ((##symbol? src)         (##comp-ref cte src tail?))
  18.           ((##self-eval? src)      (##comp-cst cte src tail?))
  19.           ((##not (##pair? src))   (ct-error-syntax "Ill-formed expression"))
  20.           (else
  21.            (let ((first (##car src)))
  22.              (if (##macro? cte first)
  23.                (##comp-top cte (##macro-expand cte src) tail?)
  24.                (case first
  25.                  ((BEGIN)          (##comp-top-BEGIN cte src tail?))
  26.                  ((DEFINE)         (##comp-top-DEFINE cte src tail?))
  27.                  ((##DECLARE)      (##comp-top-DECLARE cte src tail?))
  28.                  ((##DEFINE-MACRO) (##comp-top-DEFINE-MACRO cte src tail?))
  29.                  ((##INCLUDE)      (##comp-top-INCLUDE cte src tail?))
  30.                  (else             (##comp-aux cte src tail? first)))))))))
  31.  
  32. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  33.  
  34. (define (##comp-top-BEGIN cte src tail?)
  35.   (##shape src src -1)
  36.   (##comp-top-seq cte src tail? (##cdr src)))
  37.  
  38. (define (##comp-top-seq cte src tail? seq)
  39.   (if (##pair? seq)
  40.     (##comp-top-seq-aux cte src tail? seq)
  41.     (gen ##gen-cst (unspecified-obj))))
  42.  
  43. (define (##comp-top-seq-aux cte src tail? seq)
  44.   (let ((rest (##cdr seq)))
  45.     (if (##pair? rest)
  46.       (gen ##gen-seq
  47.         (##comp-top cte (##car seq) #f)
  48.         (##comp-top-seq-aux cte src tail? rest))
  49.       (##comp-top cte (##car seq) tail?))))
  50.  
  51. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  52.  
  53. (define (##comp-top-DEFINE cte src tail?)
  54.   (let ((cte (##make-cte #f)))
  55.     (let ((name (##definition-name src)))
  56.       (let ((ind (##cte-lookup-var cte name)))
  57.         (gen ##gen-glo-def
  58.           name
  59.           ind
  60.           (##comp cte (##definition-value src) #f))))))
  61.  
  62. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  63.  
  64. (define (##comp-top-DECLARE cte src tail?)
  65.   (##shape src src -1)
  66.   (##cte-add-global-decl (##cdr src))
  67.   (gen ##gen-cst (unspecified-obj)))
  68.  
  69. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  70.  
  71. (define (##comp-top-DEFINE-MACRO cte src tail?)
  72.   (let ((name (##definition-name src)))
  73.     (##cte-add-global-macro name (##eval-global (##definition-value src)))
  74.     (gen ##gen-cst name)))
  75.  
  76. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  77.  
  78. (define (##comp-top-INCLUDE cte src tail?)
  79.   (##shape src src 2)
  80.   (##comp-top-seq cte src tail? (##read-expressions cte src (##cadr src))))
  81.  
  82. ;------------------------------------------------------------------------------
  83.  
  84. (define (##comp cte src tail?)
  85.   (let ((src (##touch-list src)))
  86.     (cond ((##symbol? src)         (##comp-ref cte src tail?))
  87.           ((##self-eval? src)      (##comp-cst cte src tail?))
  88.           ((##not (##pair? src))   (ct-error-syntax "Ill-formed expression"))
  89.           (else
  90.            (let ((first (##car src)))
  91.              (if (##macro? cte first)
  92.                (##comp cte (##macro-expand cte src) tail?)
  93.                (case first
  94.                  ((BEGIN)          (##comp-BEGIN cte src tail?))
  95.                  ((DEFINE)         (ct-error-syntax "Ill-placed 'define'"))
  96.                  ((##DECLARE)      (ct-error-syntax "Ill-placed '##declare'"))
  97.                  ((##DEFINE-MACRO) (ct-error-syntax "Ill-placed '##define-macro'"))
  98.                  ((##INCLUDE)      (ct-error-syntax "Ill-placed '##include'"))
  99.                  (else             (##comp-aux cte src tail? first)))))))))
  100.  
  101. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  102.  
  103. (define (##comp-BEGIN cte src tail?)
  104.   (##shape src src -2)
  105.   (##comp-seq cte src tail? (##cdr src)))
  106.  
  107. (define (##comp-seq cte src tail? seq)
  108.   (if (##pair? seq)
  109.     (##comp-seq-aux cte src tail? seq)
  110.     (gen ##gen-cst (unspecified-obj))))
  111.  
  112. (define (##comp-seq-aux cte src tail? seq)
  113.   (let ((rest (##cdr seq)))
  114.     (if (##pair? rest)
  115.       (gen ##gen-seq
  116.         (##comp cte (##car seq) #f)
  117.         (##comp-seq-aux cte src tail? rest))
  118.       (##comp cte (##car seq) tail?))))
  119.  
  120. ;------------------------------------------------------------------------------
  121.  
  122. (define (##comp-aux cte src tail? first)
  123.   (case first
  124.     ((QUOTE)            (##comp-QUOTE cte src tail?))
  125.     ((QUASIQUOTE)       (##comp-QUASIQUOTE cte src tail?))
  126.     ((UNQUOTE)          (ct-error-syntax "Ill-placed 'unquote'"))
  127.     ((UNQUOTE-SPLICING) (ct-error-syntax "Ill-placed 'unquote-splicing'"))
  128.     ((SET!)             (##comp-SET! cte src tail?))
  129.     ((LAMBDA)           (##comp-LAMBDA cte src tail?))
  130.     ((IF)               (##comp-IF cte src tail?))
  131.     ((COND)             (##comp-COND cte src tail?))
  132.     ((AND)              (##comp-AND cte src tail?))
  133.     ((OR)               (##comp-OR cte src tail?))
  134.     ((CASE)             (##comp-CASE cte src tail?))
  135.     ((LET)              (##comp-LET cte src tail?))
  136.     ((LET*)             (##comp-LET* cte src tail?))
  137.     ((LETREC)           (##comp-LETREC cte src tail?))
  138.     ((DO)               (##comp-DO cte src tail?))
  139.     ((DELAY)            (##comp-DELAY cte src tail?))
  140.     ((FUTURE)           (##comp-FUTURE cte src tail?))
  141.     (else               (##comp-app cte src tail?))))
  142.  
  143. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  144.  
  145. (define (##comp-ref cte src tail?)
  146.   (##variable src src)
  147.   (let ((x (##cte-lookup-var cte src)))
  148.     (if (loc-access? x)
  149.       (let ((up (loc-access-up x))
  150.             (over (loc-access-over x)))
  151.         (gen ##gen-loc-ref up over))
  152.       (gen ##gen-glo-ref x))))
  153.  
  154. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  155.  
  156. (define (##comp-cst cte src tail?)
  157.   (gen ##gen-cst src))
  158.  
  159. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  160.  
  161. (define (##comp-QUOTE cte src tail?)
  162.   (##shape src src 2)
  163.   (gen ##gen-cst (##cadr src)))
  164.  
  165. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  166.  
  167. (define (##comp-QUASIQUOTE cte src tail?)
  168.   (##comp-quasi cte src tail? (##touch-list (##cadr src)) 1))
  169.  
  170. (define (##comp-quasi cte src tail? form level)
  171.   (cond ((##eq? level 0)
  172.          (##comp cte form tail?))
  173.         ((##pair? form)
  174.          (let ((x (##car form)))
  175.            (touch-vars (x)
  176.              (case x
  177.                ((QUASIQUOTE)
  178.                 (##comp-quasi-list cte src tail? form (##fixnum.+ level 1)))
  179.                ((UNQUOTE)
  180.                 (if (##eq? level 1)
  181.                   (##comp cte (##cadr form) tail?)
  182.                   (##comp-quasi-list cte src tail? form (##fixnum.- level 1))))
  183.                ((UNQUOTE-SPLICING)
  184.                 (if (##eq? level 1)
  185.                   (ct-error-syntax "Ill-placed 'unquote-splicing'"))
  186.                 (##comp-quasi-list cte src tail? form (##fixnum.- level 1)))
  187.                (else
  188.                 (##comp-quasi-list cte src tail? form level))))))
  189.         ((##vector? form)
  190.          (gen ##gen-quasi-list->vector
  191.            (##comp-quasi-list cte src #f (##vector->list form) level)))
  192.         (else
  193.          (gen ##gen-cst form))))
  194.  
  195. (define (##comp-quasi-list cte src tail? l level)
  196.   (if (##pair? l)
  197.     (let ((first (##touch-list (##car l))))
  198.       (if (and (##eq? level 1) (##unquote-splicing? first))
  199.         (begin
  200.           (##shape src first 2)
  201.           (if (##null? (##cdr l))
  202.             (##comp cte (##cadr first) tail?)
  203.             (gen ##gen-quasi-append
  204.               (##comp cte (##cadr first) #f)
  205.               (##comp-quasi cte src #f (##cdr l) 1))))
  206.         (gen ##gen-quasi-cons
  207.           (##comp-quasi cte src #f first level)
  208.           (##comp-quasi cte src #f (##cdr l) level))))
  209.     (##comp-quasi cte src tail? l level)))
  210.  
  211. (define (##unquote-splicing? x)
  212.   (and (##pair? x)
  213.        (let ((y (##car x)))
  214.          (touch-vars (y)
  215.            (##eq? y 'UNQUOTE-SPLICING)))))
  216.  
  217. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  218.  
  219. (define (##comp-SET! cte src tail?)
  220.   (##shape src src 3)
  221.   (let ((var (##cadr src)))
  222.     (touch-vars (var)
  223.       (begin
  224.         (##variable src var)
  225.         (let ((x (##cte-lookup-var cte var)))
  226.           (if (loc-access? x)
  227.             (let ((up (loc-access-up x))
  228.                   (over (loc-access-over x)))
  229.               (gen ##gen-loc-set up over (##comp cte (##caddr src) #f)))
  230.             (gen ##gen-glo-set x (##comp cte (##caddr src) #f))))))))
  231.  
  232. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  233.  
  234. (define (##comp-LAMBDA cte src tail?)
  235.   (##shape src src -3)
  236.   (##comp-lambda-aux cte src tail? (##touch-list (##cadr src)) (##cddr src)))
  237.  
  238. (define (##comp-lambda-aux cte src tail? parms body)
  239.   (let ((frame (##parms->frame src parms)))
  240.     (let ((c (##comp-body (##cte-push-frame cte (##cons (self-var) frame)) src #t body)))
  241.       (if (##rest-param? parms)
  242.         (gen ##gen-prc-rest frame c)
  243.         (gen ##gen-prc frame c)))))
  244.  
  245. (define (##parms->frame src parms)
  246.   (cond ((##null? parms)
  247.          '())
  248.         ((##pair? parms)
  249.          (let ((x (##car parms)))
  250.            (touch-vars (x)
  251.              (let ((rest (##parms->frame src (##cdr parms))))
  252.                (##variable src x)
  253.                (if (##memq x rest)
  254.                  (ct-error-syntax "Duplicate parameter in parameter list"))
  255.                (##cons x rest)))))
  256.         (else
  257.          (##variable src parms)
  258.          (##list parms))))
  259.  
  260. (define (##rest-param? parms)
  261.   (cond ((##pair? parms)
  262.          (##rest-param? (##cdr parms)))
  263.         ((##null? parms)
  264.          #f)
  265.         (else
  266.          #t)))
  267.  
  268. (define (##comp-body cte src tail? body)
  269.  
  270.   (define (letrec-defines cte vars vals body)
  271.     (if (##pair? body)
  272.  
  273.       (let ((src (##touch-list (##car body))))
  274.         (if (##not (##pair? src))
  275.           (letrec-defines* cte vars vals body)
  276.           (let ((first (##car src)))
  277.             (touch-vars (first)
  278.               (if (##macro? cte first)
  279.                 (letrec-defines cte
  280.                                 vars
  281.                                 vals
  282.                                 (##cons (##macro-expand cte src) (##cdr body)))
  283.                 (case first
  284.                   ((BEGIN)
  285.                    (letrec-defines cte
  286.                                    vars
  287.                                    vals
  288.                                    (##append (##cdr src) (##cdr body))))
  289.                   ((DEFINE)
  290.                    (let ((x (##definition-name src)))
  291.                      (##variable src x)
  292.                      (if (##memq x vars)
  293.                        (ct-error-syntax "Duplicate definition of a variable"))
  294.                      (letrec-defines cte
  295.                                      (##cons x vars)
  296.                                      (##cons (##definition-value src) vals)
  297.                                      (##cdr body))))
  298.                   ((##DECLARE)
  299.                    (##shape src src -1)
  300.                    (letrec-defines (##cte-push-decl cte (##cdr src))
  301.                                    vars
  302.                                    vals
  303.                                    (##cdr body)))
  304.                   ((##DEFINE-MACRO)
  305.                    (let ((x (##definition-name src)))
  306.                      (letrec-defines (##cte-push-macro
  307.                                        cte
  308.                                        x
  309.                                        (##eval-global (##definition-value src)))
  310.                                      vars
  311.                                      vals
  312.                                      (##cdr body))))
  313.                   ((##INCLUDE)
  314.                    (##shape src src 2)
  315.                    (letrec-defines cte
  316.                                    vars
  317.                                    vals
  318.                                    (##append (##read-expressions cte src (##cadr src))
  319.                                              (##cdr body))))
  320.                   (else
  321.                    (letrec-defines* cte vars vals body))))))))
  322.  
  323.       (ct-error-syntax "Body must contain at least one evaluable expression")))
  324.  
  325.   (define (letrec-defines* cte vars vals body)
  326.     (if (##null? vars)
  327.       (##comp-seq cte src tail? body)
  328.       (##comp-letrec-aux cte src tail? vars vals body)))
  329.  
  330.   (letrec-defines cte '() '() body))
  331.  
  332. (define (##definition-name src)
  333.   (##shape src src -3)
  334.   (let ((pattern (##cadr src)))
  335.     (touch-vars (pattern)
  336.       (let ((name (if (##pair? pattern)
  337.                     (let ((name (##car pattern)))
  338.                       (touch-vars (name)
  339.                         name))
  340.                     (begin
  341.                       (##shape src src 3)
  342.                       pattern))))
  343.         (if (##not (##symbol? name))
  344.           (ct-error-syntax "Defined variable must be an identifier"))
  345.         name))))
  346.  
  347. (define (##definition-value src)
  348.   (let ((pattern (##cadr src)))
  349.     (touch-vars (pattern)
  350.       (if (##pair? pattern)
  351.         (##cons 'LAMBDA (##cons (##cdr pattern) (##cddr src)))
  352.         (##caddr src)))))
  353.  
  354. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  355.  
  356. (define (##comp-IF cte src tail?)
  357.   (##shape src src -3)
  358.   (if (##pair? (##cdddr src))
  359.     (begin
  360.       (##shape src src 4)
  361.       (gen ##gen-if3
  362.         (##comp cte (##cadr src) #f)
  363.         (##comp cte (##caddr src) tail?)
  364.         (##comp cte (##cadddr src) tail?)))
  365.     (begin
  366.       (##shape src src 3)
  367.       (gen ##gen-if2
  368.         (##comp cte (##cadr src) #f)
  369.         (##comp cte (##caddr src) tail?)))))
  370.  
  371. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  372.  
  373. (define (##comp-COND cte src tail?)
  374.   (##shape src src -2)
  375.   (##comp-cond-aux cte src tail? (##cdr src)))
  376.  
  377. (define (##comp-cond-aux cte src tail? clauses)
  378.   (if (##pair? clauses)
  379.     (let ((clause (##touch-list (##car clauses))))
  380.       (##shape src clause -1)
  381.       (let ((x (##car clause)))
  382.         (touch-vars (x)
  383.           (cond ((##eq? x 'ELSE)
  384.                  (##shape src clause -2)
  385.                  (if (##not (##null? (##cdr clauses)))
  386.                    (ct-error-syntax "ELSE clause must be last"))
  387.                  (##comp-seq cte src tail? (##cdr clause)))
  388.                 ((##not (##pair? (##cdr clause)))
  389.                  (gen ##gen-cond-or
  390.                     (##comp cte (##car clause) #f)
  391.                     (##comp-cond-aux cte src tail? (##cdr clauses))))
  392.                 (else
  393.                  (let ((y (##cadr clause)))
  394.                    (touch-vars (y)
  395.                      (if (##eq? y '=>)
  396.                        (begin
  397.                          (##shape src clause -3)
  398.                          (gen ##gen-cond-send
  399.                            (##comp cte (##car clause) #f)
  400.                            (##comp cte (##caddr clause) #f)
  401.                            (##comp-cond-aux cte src tail? (##cdr clauses))))
  402.                        (gen ##gen-cond-if
  403.                          (##comp cte (##car clause) #f)
  404.                          (##comp-seq cte src tail? (##cdr clause))
  405.                          (##comp-cond-aux cte src tail? (##cdr clauses)))))))))))
  406.     (gen ##gen-cst (unspecified-obj))))
  407.  
  408. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  409.  
  410. (define (##comp-AND cte src tail?)
  411.   (let ((rest (##cdr src)))
  412.     (if (##pair? rest)
  413.       (##comp-and-aux cte src tail? rest)
  414.       (gen ##gen-cst #t))))
  415.  
  416. (define (##comp-and-aux cte src tail? l)
  417.   (let ((rest (##cdr l)))
  418.     (if (##pair? rest)
  419.       (gen ##gen-and
  420.         (##comp cte (##car l) #f)
  421.         (##comp-and-aux cte src tail? rest))
  422.       (##comp cte (##car l) tail?))))
  423.  
  424. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  425.  
  426. (define (##comp-OR cte src tail?)
  427.   (let ((rest (##cdr src)))
  428.     (if (##pair? rest)
  429.       (##comp-or-aux cte src tail? rest)
  430.       (gen ##gen-cst #f))))
  431.  
  432. (define (##comp-or-aux cte src tail? l)
  433.   (let ((rest (##cdr l)))
  434.     (if (##pair? rest)
  435.       (gen ##gen-or
  436.         (##comp cte (##car l) #f)
  437.         (##comp-or-aux cte src tail? rest))
  438.       (##comp cte (##car l) tail?))))
  439.  
  440. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  441.  
  442. (define (##comp-CASE cte src tail?)
  443.   (##shape src src -3)
  444.   (gen ##gen-case
  445.     (##comp cte (##cadr src) #f)
  446.     (let ((cte (##cte-push-frame cte (##list (selector-var)))))
  447.       (##comp-case-aux cte src tail? (##cddr src)))))
  448.  
  449. (define (##comp-case-aux cte src tail? clauses)
  450.   (if (##pair? clauses)
  451.     (let ((clause (##touch-list (##car clauses))))
  452.       (##shape src clause -2)
  453.       (let ((first (##touch-list (##car clause))))
  454.         (if (##eq? first 'ELSE)
  455.           (begin
  456.             (if (##not (##null? (##cdr clauses)))
  457.               (ct-error-syntax "ELSE clause must be last"))
  458.             (gen ##gen-case-else
  459.               (##comp-seq cte src tail? (##cdr clause))))
  460.           (gen ##gen-case-clause
  461.             first
  462.             (##comp-seq cte src tail? (##cdr clause))
  463.             (##comp-case-aux cte src tail? (##cdr clauses))))))
  464.     (gen ##gen-case-else
  465.       (gen ##gen-cst (unspecified-obj)))))
  466.  
  467. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  468.  
  469. (define (##comp-LET cte src tail?)
  470.   (##shape src src -3)
  471.   (let ((x (##touch-list (##cadr src))))
  472.     (cond ((##symbol? x)
  473.            (##shape src src -4)
  474.            (let ((bindings (##touch-list (##caddr src))))
  475.              (let* ((vars (##bindings->vars src bindings #t))
  476.                     (vals (##bindings->vals bindings)))
  477.                (gen ##gen-app
  478.                  (let ((inner-cte (##cte-push-frame cte (##list x))))
  479.                    (gen ##gen-letrec
  480.                      (##list x)
  481.                      (let ((cte inner-cte)
  482.                            (tail? #f))
  483.                        (##list (gen ##gen-prc
  484.                                vars
  485.                                (##comp-body (##cte-push-frame cte (##cons (self-var) vars))
  486.                                             src
  487.                                             #t
  488.                                             (##cdddr src)))))
  489.                      (let ((cte inner-cte)
  490.                            (tail? #f))
  491.                        (gen ##gen-loc-ref 0 1)))) ; fetch loop variable
  492.                  (##comp-vals cte vals)))))
  493.           ((##null? x)
  494.            (##comp-body cte src tail? (##cddr src)))
  495.           (else
  496.            (let* ((bindings x)
  497.                   (vars (##bindings->vars src bindings #t))
  498.                   (vals (##bindings->vals bindings)))
  499.              (let ((c (##comp-body (##cte-push-frame cte vars) src tail? (##cddr src))))
  500.                (gen ##gen-let
  501.                  vars
  502.                  (##comp-vals cte vals)
  503.                  c)))))))
  504.  
  505. (define (##comp-vals cte l)
  506.   (if (##pair? l)
  507.     (##cons (##comp cte (##car l) #f) (##comp-vals cte (##cdr l)))
  508.     '()))
  509.  
  510. (define (##bindings->vars src bindings check-duplicates?)
  511.   (if (##pair? bindings)
  512.     (let ((binding (##touch-list (##car bindings))))
  513.       (##shape src binding 2)
  514.       (let ((x (##car binding)))
  515.         (touch-vars (x)
  516.           (let ((rest (##bindings->vars src (##cdr bindings) check-duplicates?)))
  517.             (##variable src x)
  518.             (if (and check-duplicates? (##memq x rest))
  519.               (ct-error-syntax "Duplicate variable in bindings"))
  520.             (##cons x rest)))))
  521.     (if (##null? bindings)
  522.       '()
  523.       (ct-error-syntax "Ill-terminated bindings"))))
  524.  
  525. (define (##bindings->vals bindings)
  526.   (if (##pair? bindings)
  527.     (let ((binding (##touch-list (##car bindings))))
  528.       (##cons (##cadr binding) (##bindings->vals (##cdr bindings))))
  529.     '()))
  530.  
  531. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  532.  
  533. (define (##comp-LET* cte src tail?)
  534.   (##shape src src -3)
  535.   (let ((bindings (##cadr src)))
  536.     (touch-vars (bindings)
  537.       (let* ((vars (##bindings->vars src bindings #f))
  538.              (vals (##bindings->vals bindings)))
  539.         (##comp-let*-aux cte src tail? vars vals (##cddr src))))))
  540.  
  541. (define (##comp-let*-aux cte src tail? vars vals body)
  542.   (if (##pair? vars)
  543.     (let ((frame (##list (##car vars))))
  544.       (let ((inner-cte (##cte-push-frame cte frame)))
  545.         (gen ##gen-let
  546.           frame
  547.           (##list (##comp cte (##car vals) #f))
  548.           (##comp-let*-aux inner-cte src tail? (##cdr vars) (##cdr vals) body))))
  549.     (##comp-body cte src tail? body)))
  550.  
  551. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  552.  
  553. (define (##comp-LETREC cte src tail?)
  554.   (##shape src src -3)
  555.   (let ((bindings (##touch-list (##cadr src))))
  556.     (if (##null? bindings)
  557.       (##comp-body cte src tail? (##cddr src))
  558.       (let* ((vars (##bindings->vars src bindings #t))
  559.              (vals (##bindings->vals bindings)))
  560.         (##comp-letrec-aux cte src tail? vars vals (##cddr src))))))
  561.  
  562. (define (##comp-letrec-aux cte src tail? vars vals body)
  563.   (if (##pair? vars)
  564.     (let ((inner-cte (##cte-push-frame cte vars)))
  565.       (gen ##gen-letrec
  566.         vars
  567.         (##comp-vals inner-cte vals)
  568.         (##comp-body inner-cte src tail? body)))
  569.     (##comp-body cte src tail? body)))
  570.  
  571. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  572.  
  573. (define (##comp-do cte src tail?)
  574.   (##shape src src -3)
  575.   (let ((bindings (##touch-list (##cadr src)))
  576.         (exit (##touch-list (##caddr src))))
  577.     (##shape src exit -1)
  578.     (let* ((vars (##bindings->vars* src bindings))
  579.            (do-loop-vars (##list (do-loop-var)))
  580.            (inner-cte (##cte-push-frame cte do-loop-vars)))
  581.       (gen ##gen-letrec
  582.         do-loop-vars
  583.         (##list
  584.           (let ((cte inner-cte)
  585.                 (tail? #f))
  586.             (gen ##gen-prc
  587.               vars
  588.               (let ((cte (##cte-push-frame cte (##cons (self-var) vars)))
  589.                     (tail? #t))
  590.                 (gen ##gen-if3
  591.                   (##comp cte (##car exit) #f)
  592.                   (##comp-seq cte src tail? (##cdr exit))
  593.                   (let ((call
  594.                           (gen ##gen-app
  595.                             (let ((tail? #f))
  596.                               (gen ##gen-loc-ref 1 1)) ; fetch do-loop-var
  597.                             (##comp-vals cte (##bindings->steps bindings)))))
  598.                     (if (##null? (##cdddr src))
  599.                       call
  600.                       (gen ##gen-seq
  601.                         (##comp-seq cte src #f (##cdddr src))
  602.                         call))))))))
  603.         (let ((cte inner-cte))
  604.           (gen ##gen-app
  605.             (let ((tail? #f))
  606.               (gen ##gen-loc-ref 0 1)) ; fetch do-loop-var
  607.             (##comp-vals cte (##bindings->vals bindings))))))))
  608.  
  609. (define (##bindings->vars* src bindings)
  610.   (if (##pair? bindings)
  611.     (let ((binding (##touch-list (##car bindings))))
  612.       (##shape src binding -2)
  613.       (if (##pair? (##cddr binding)) (##shape src binding 3))
  614.       (let ((x (##car binding)))
  615.         (touch-vars (x)
  616.           (let ((rest (##bindings->vars* src (##cdr bindings))))
  617.             (##variable src x)
  618.             (if (##memq x rest)
  619.               (ct-error-syntax "Duplicate variable in bindings"))
  620.             (##cons x rest)))))
  621.     (if (##null? bindings)
  622.       '()
  623.       (ct-error-syntax "Ill-terminated bindings"))))
  624.  
  625. (define (##bindings->steps bindings)
  626.   (if (##pair? bindings)
  627.     (let ((binding (##touch-list (##car bindings))))
  628.       (##cons (if (##pair? (##cddr binding)) (##caddr binding) (##car binding))
  629.               (##bindings->steps (##cdr bindings))))
  630.     '()))
  631.  
  632. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  633.  
  634. (define (##comp-app cte src tail?)
  635.   (let ((n (##proper-length src)))
  636.     (if n
  637.       (gen ##gen-app
  638.         (##comp cte (##car src) #f)
  639.         (##comp-vals cte (##cdr src)))
  640.       (ct-error-syntax "Ill-formed procedure application"))))
  641.  
  642. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  643.  
  644. (define (##comp-DELAY cte src tail?)
  645.   (##shape src src 2)
  646.   (gen ##gen-delay (##comp cte (##cadr src) #t)))
  647.  
  648. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  649.  
  650. (define (##comp-FUTURE cte src tail?)
  651.   (##shape src src 2)
  652.   (gen ##gen-future (##comp cte (##cadr src) #t)))
  653.  
  654. ;==============================================================================
  655.  
  656. ; Code generation procedures
  657.  
  658. ;------------------------------------------------------------------------------
  659.  
  660. ; Macros to manipulate the runtime environment
  661.  
  662. (##define-macro (mk-rte rte . lst)
  663.   (let ((n (length lst)))
  664.     `(let (($rte (##make-vector ,(+ n 1) (unspecified-obj))))
  665.        (##vector-set! $rte 0 ,rte)
  666.        ,@(let loop2 ((l lst) (i 1) (r '()))
  667.            (if (pair? l)
  668.              (loop2 (cdr l) (+ i 1) (cons `(##vector-set! $rte ,i ,(car l)) r))
  669.              (reverse r)))
  670.        $rte)))
  671.  
  672. (##define-macro (mk-rte* rte n)
  673.   `(let (($rte (##make-vector (##fixnum.+ ,n 1) (unspecified-obj))))
  674.      (##vector-set! $rte 0 ,rte)
  675.      $rte))
  676.  
  677. (##define-macro (rte-up rte)         `(##vector-ref ,rte 0))
  678. (##define-macro (rte-ref rte i)      `(##vector-ref ,rte ,i))
  679. (##define-macro (rte-set! rte i val) `(##vector-set! ,rte ,i ,val))
  680.  
  681. ;------------------------------------------------------------------------------
  682.  
  683. (define ##cprc-top
  684.   (mk-cprc
  685.     (##subproblem-apply0 $code rte
  686.       (lambda ()
  687.         (let ((rte (mk-rte rte #f)))
  688.           (code-run (^ 0)))))))
  689.  
  690. (define ##gen-top
  691.   (mk-gen (frames val)
  692.     (mk-code ##cprc-top (val) frames)))
  693.  
  694. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  695.  
  696. (define ##cprc-cst-null  (mk-cprc '()))
  697. (define ##cprc-cst-true  (mk-cprc #t))
  698. (define ##cprc-cst-false (mk-cprc #f))
  699. (define ##cprc-cst--2    (mk-cprc -2))
  700. (define ##cprc-cst--1    (mk-cprc -1))
  701. (define ##cprc-cst-0     (mk-cprc 0))
  702. (define ##cprc-cst-1     (mk-cprc 1))
  703. (define ##cprc-cst-2     (mk-cprc 2))
  704. (define ##cprc-cst       (mk-cprc (^ 0)))
  705.  
  706. (define ##gen-cst
  707.   (mk-gen (val)
  708.     (case val
  709.       ((()) (mk-code ##cprc-cst-null  ()))
  710.       ((#t) (mk-code ##cprc-cst-true  ()))
  711.       ((#f) (mk-code ##cprc-cst-false ()))
  712.       ((-2) (mk-code ##cprc-cst--2    ()))
  713.       ((-1) (mk-code ##cprc-cst--1    ()))
  714.       ((0)  (mk-code ##cprc-cst-0     ()))
  715.       ((1)  (mk-code ##cprc-cst-1     ()))
  716.       ((2)  (mk-code ##cprc-cst-2     ()))
  717.       (else (mk-code ##cprc-cst       () val)))))
  718.  
  719. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  720.  
  721. (define ##cprc-loc-ref-0-1 (mk-cprc (rte-ref rte 1)))
  722. (define ##cprc-loc-ref-0-2 (mk-cprc (rte-ref rte 2)))
  723. (define ##cprc-loc-ref-0-3 (mk-cprc (rte-ref rte 3)))
  724.  
  725. (define ##cprc-loc-ref-1-1 (mk-cprc (rte-ref (rte-up rte) 1)))
  726. (define ##cprc-loc-ref-1-2 (mk-cprc (rte-ref (rte-up rte) 2)))
  727. (define ##cprc-loc-ref-1-3 (mk-cprc (rte-ref (rte-up rte) 3)))
  728.  
  729. (define ##cprc-loc-ref-2-1 (mk-cprc (rte-ref (rte-up (rte-up rte)) 1)))
  730. (define ##cprc-loc-ref-2-2 (mk-cprc (rte-ref (rte-up (rte-up rte)) 2)))
  731. (define ##cprc-loc-ref-2-3 (mk-cprc (rte-ref (rte-up (rte-up rte)) 3)))
  732.  
  733. (define ##cprc-loc-ref
  734.   (mk-cprc
  735.     (let loop ((e rte) (i (^ 0)))
  736.       (if (##fixnum.< 0 i)
  737.         (loop (rte-up e) (##fixnum.- i 1))
  738.         (rte-ref e (^ 1))))))
  739.  
  740. (define ##gen-loc-ref
  741.   (mk-gen (up over)
  742.     (case up
  743.       ((0)
  744.        (case over
  745.          ((1)  (mk-code ##cprc-loc-ref-0-1 ()))
  746.          ((2)  (mk-code ##cprc-loc-ref-0-2 ()))
  747.          ((3)  (mk-code ##cprc-loc-ref-0-3 ()))
  748.          (else (mk-code ##cprc-loc-ref     () up over))))
  749.       ((1)
  750.        (case over
  751.          ((1)  (mk-code ##cprc-loc-ref-1-1 ()))
  752.          ((2)  (mk-code ##cprc-loc-ref-1-2 ()))
  753.          ((3)  (mk-code ##cprc-loc-ref-1-3 ()))
  754.          (else (mk-code ##cprc-loc-ref     () up over))))
  755.       ((2)
  756.        (case over
  757.          ((1)  (mk-code ##cprc-loc-ref-2-1 ()))
  758.          ((2)  (mk-code ##cprc-loc-ref-2-2 ()))
  759.          ((3)  (mk-code ##cprc-loc-ref-2-3 ()))
  760.          (else (mk-code ##cprc-loc-ref     () up over))))
  761.      (else
  762.        (mk-code ##cprc-loc-ref () up over)))))
  763.  
  764. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  765.  
  766. (define ##cprc-glo-ref
  767.   (mk-cprc
  768.     (let loop ((val (global-env-ref (^ 0))))
  769.       (if (unbound? val)
  770.         (loop (rt-error-unbound-global-var $code rte))
  771.         val))))
  772.  
  773. (define ##gen-glo-ref
  774.   (mk-gen (ind)
  775.     (mk-code ##cprc-glo-ref () ind)))
  776.  
  777. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  778.  
  779. (define ##cprc-loc-set
  780.   (mk-cprc
  781.     (let ((val (code-run (^ 0))))
  782.       (let loop ((e rte) (i (^ 1)))
  783.         (if (##fixnum.< 0 i)
  784.           (loop (rte-up e) (##fixnum.- i 1))
  785.           (begin
  786.             (rte-set! e (^ 2) val)
  787.             (set!-ret-obj)))))))
  788.  
  789. (define ##gen-loc-set
  790.   (mk-gen (up over val)
  791.     (mk-code ##cprc-loc-set (val) up over)))
  792.  
  793. (define ##cprc-glo-set
  794.   (mk-cprc
  795.     (let ((val (code-run (^ 0))))
  796.       (global-env-set! (^ 1) val)
  797.       (set!-ret-obj))))
  798.  
  799. (define ##gen-glo-set
  800.   (mk-gen (ind val)
  801.     (mk-code ##cprc-glo-set (val) ind)))
  802.  
  803. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  804.  
  805. (define ##cprc-glo-def
  806.   (mk-cprc
  807.     (let ((rte #f))
  808.       (global-env-set! (^ 1) (code-run (^ 0)))
  809.       (^ 2))))
  810.  
  811. (define ##gen-glo-def
  812.   (mk-gen (name ind val)
  813.     (mk-code ##cprc-glo-def (val) ind name)))
  814.  
  815. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  816.  
  817. (define ##cprc-if2
  818.   (mk-cprc
  819.     (let ((pred (code-run (^ 0))))
  820.       (touch-vars (pred)
  821.         (if (true? pred)
  822.           (code-run (^ 1))
  823.           (unspecified-obj))))))
  824.  
  825. (define ##gen-if2
  826.   (mk-gen (pre con)
  827.     (mk-code ##cprc-if2 (pre con))))
  828.  
  829. (define ##cprc-if3
  830.   (mk-cprc
  831.     (let ((pred (code-run (^ 0))))
  832.       (touch-vars (pred)
  833.         (if (true? pred)
  834.           (code-run (^ 1))
  835.           (code-run (^ 2)))))))
  836.  
  837. (define ##gen-if3
  838.   (mk-gen (pre con alt)
  839.     (mk-code ##cprc-if3 (pre con alt))))
  840.  
  841. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  842.  
  843. (define ##cprc-seq
  844.   (mk-cprc
  845.     (code-run (^ 0))
  846.     (code-run (^ 1))))
  847.  
  848. (define ##gen-seq
  849.   (mk-gen (val1 val2)
  850.     (mk-code ##cprc-seq (val1 val2))))
  851.  
  852. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  853.  
  854. (define ##cprc-quasi-list->vector
  855.   (mk-cprc
  856.     (quasi-list->vector (code-run (^ 0)))))
  857.  
  858. (define ##gen-quasi-list->vector
  859.   (mk-gen (val)
  860.     (mk-code ##cprc-quasi-list->vector (val))))
  861.  
  862. (define ##cprc-quasi-append
  863.   (mk-cprc
  864.     (quasi-append (code-run (^ 0)) (code-run (^ 1)))))
  865.  
  866. (define ##gen-quasi-append
  867.   (mk-gen (val1 val2)
  868.     (mk-code ##cprc-quasi-append (val1 val2))))
  869.  
  870. (define ##cprc-quasi-cons
  871.   (mk-cprc
  872.     (quasi-cons (code-run (^ 0)) (code-run (^ 1)))))
  873.  
  874. (define ##gen-quasi-cons
  875.   (mk-gen (val1 val2)
  876.     (mk-code ##cprc-quasi-cons (val1 val2))))
  877.  
  878. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  879.  
  880. (define ##cprc-cond-if
  881.   (mk-cprc
  882.     (let ((pred (code-run (^ 0))))
  883.       (touch-vars (pred)
  884.         (if (true? pred)
  885.           (code-run (^ 1))
  886.           (code-run (^ 2)))))))
  887.  
  888. (define ##gen-cond-if
  889.   (mk-gen (val1 val2 val3)
  890.     (mk-code ##cprc-cond-if (val1 val2 val3))))
  891.  
  892. (define ##cprc-cond-or
  893.   (mk-cprc
  894.     (let ((pred (code-run (^ 0))))
  895.       (touch-vars (pred)
  896.         (if (true? pred)
  897.           pred
  898.           (code-run (^ 1)))))))
  899.  
  900. (define ##gen-cond-or
  901.   (mk-gen (val1 val2)
  902.     (mk-code ##cprc-cond-or (val1 val2))))
  903.  
  904. (define ##cprc-cond-send-red
  905.   (mk-cprc
  906.     (let ((pred (code-run (^ 0))))
  907.       (touch-vars (pred)
  908.         (if (true? pred)
  909.           (let loop ((proc (code-run (^ 1))))
  910.             (touch-vars (proc)
  911.               (if (##not (##procedure? proc))
  912.                 (loop (rt-error-non-procedure-send $code rte))
  913.                 (##reduction-apply1 $code rte proc pred))))
  914.           (code-run (^ 2)))))))
  915.  
  916. (define ##cprc-cond-send-sub
  917.   (mk-cprc
  918.     (let ((pred (code-run (^ 0))))
  919.       (touch-vars (pred)
  920.         (if (true? pred)
  921.           (let loop ((proc (code-run (^ 1))))
  922.             (touch-vars (proc)
  923.               (if (##not (##procedure? proc))
  924.                 (loop (rt-error-non-procedure-send $code rte))
  925.                 (##subproblem-apply1 $code rte proc pred))))
  926.           (code-run (^ 2)))))))
  927.  
  928. (define ##gen-cond-send
  929.   (mk-gen (val1 val2 val3)
  930.     (mk-code (if tail? ##cprc-cond-send-red ##cprc-cond-send-sub)
  931.              (val1 val2 val3))))
  932.  
  933. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  934.  
  935. (define ##cprc-or
  936.   (mk-cprc
  937.     (let ((pred (code-run (^ 0))))
  938.       (touch-vars (pred)
  939.         (if (true? pred)
  940.           pred
  941.           (code-run (^ 1)))))))
  942.  
  943. (define ##gen-or
  944.   (mk-gen (val1 val2)
  945.     (mk-code ##cprc-or (val1 val2))))
  946.  
  947. (define ##cprc-and
  948.   (mk-cprc
  949.     (let ((pred (code-run (^ 0))))
  950.       (touch-vars (pred)
  951.         (if (##not (true? pred))
  952.           pred
  953.           (code-run (^ 1)))))))
  954.  
  955. (define ##gen-and
  956.   (mk-gen (val1 val2)
  957.     (mk-code ##cprc-and (val1 val2))))
  958.  
  959. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  960.  
  961. (define ##cprc-case
  962.   (mk-cprc
  963.     (let ((selector (code-run (^ 0))))
  964.       (touch-vars (selector)
  965.         (let ((rte (mk-rte rte selector)))
  966.           (code-run (^ 1)))))))
  967.  
  968. (define ##gen-case
  969.   (mk-gen (val1 val2)
  970.     (mk-code ##cprc-case (val1 val2))))
  971.  
  972. (define ##cprc-case-clause
  973.   (mk-cprc
  974.     (if (##case-memv (rte-ref rte 1) (^ 2))
  975.       (code-run (^ 0))
  976.       (code-run (^ 1)))))
  977.  
  978. (define ##gen-case-clause
  979.   (mk-gen (cases val1 val2)
  980.     (mk-code ##cprc-case-clause (val1 val2) cases)))
  981.  
  982. (define ##cprc-case-else
  983.   (mk-cprc
  984.     (code-run (^ 0))))
  985.  
  986. (define ##gen-case-else
  987.   (mk-gen (val)
  988.     (mk-code ##cprc-case-else (val))))
  989.  
  990. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  991.  
  992. (define ##cprc-let
  993.   (mk-cprc
  994.     (let ((n (##fixnum.- (code-length $code) 2)))
  995.       (let ((inner-rte (mk-rte* rte n)))
  996.         (let loop ((i n))
  997.           (if (##fixnum.< 0 i)
  998.             (begin
  999.               (rte-set! inner-rte i (code-run (code-ref $code i)))
  1000.               (loop (##fixnum.- i 1)))
  1001.             (let ((rte inner-rte))
  1002.               (code-run (^ 0)))))))))
  1003.  
  1004. (define ##gen-let
  1005.   (mk-gen (vars vals body)
  1006.     (let ((c (##mk-code* ##cprc-let (##cons body vals) 1)))
  1007.       (code-set! c (##fixnum.+ (##length vals) 1) vars)
  1008.       c)))
  1009.  
  1010. (define ##cprc-letrec
  1011.   (mk-cprc
  1012.     (let ((n (##fixnum.- (code-length $code) 2)))
  1013.       (let ((rte (mk-rte* rte n)))
  1014.         (let loop ((i n))
  1015.           (if (##fixnum.< 0 i)
  1016.             (begin
  1017.               (rte-set! rte i (code-run (code-ref $code i)))
  1018.               (loop (##fixnum.- i 1)))
  1019.             (code-run (^ 0))))))))
  1020.  
  1021. (define ##gen-letrec
  1022.   (mk-gen (vars vals body)
  1023.     (let ((c (##mk-code* ##cprc-letrec (##cons body vals) 1)))
  1024.       (code-set! c (##fixnum.+ (##length vals) 1) vars)
  1025.       c)))
  1026.  
  1027. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1028.  
  1029. (define ##cprc-prc0
  1030.   (mk-cprc
  1031.     (letrec ((proc
  1032.                (lambda ()
  1033.                  (let ((rte (mk-rte rte proc)))
  1034.                    (code-run (^ 0))))))
  1035.       proc)))
  1036.  
  1037. (define ##cprc-prc1
  1038.   (mk-cprc
  1039.     (letrec ((proc
  1040.                (lambda (arg1)
  1041.                  (let ((rte (mk-rte rte proc arg1)))
  1042.                    (code-run (^ 0))))))
  1043.       proc)))
  1044.  
  1045. (define ##cprc-prc2
  1046.   (mk-cprc
  1047.     (letrec ((proc
  1048.                (lambda (arg1 arg2)
  1049.                  (let ((rte (mk-rte rte proc arg1 arg2)))
  1050.                    (code-run (^ 0))))))
  1051.       proc)))
  1052.  
  1053. (define ##cprc-prc3
  1054.   (mk-cprc
  1055.     (letrec ((proc
  1056.                (lambda (arg1 arg2 arg3)
  1057.                  (let ((rte (mk-rte rte proc arg1 arg2 arg3)))
  1058.                    (code-run (^ 0))))))
  1059.       proc)))
  1060.  
  1061. (define ##cprc-prc
  1062.   (mk-cprc
  1063.     (letrec ((proc
  1064.                (lambda args
  1065.                  (let ((n (^ 1)))
  1066.                    (let ((inner-rte (mk-rte* rte n)))
  1067.                      (rte-set! inner-rte 1 proc)
  1068.                      (let loop ((i 2) (l args))
  1069.                        (if (##fixnum.< n i)
  1070.                          (if (##pair? l)
  1071.                            (rt-error-too-many-args proc args)
  1072.                            (let ((rte inner-rte))
  1073.                              (code-run (^ 0))))
  1074.                          (if (##pair? l)
  1075.                            (begin
  1076.                              (rte-set! inner-rte i (##car l))
  1077.                              (loop (##fixnum.+ i 1) (##cdr l)))
  1078.                            (rt-error-too-few-args proc args)))))))))
  1079.       proc)))
  1080.  
  1081. (define ##gen-prc
  1082.   (mk-gen (frame body)
  1083.     (case (##length frame)
  1084.       ((0)  (mk-code ##cprc-prc0 (body) frame))
  1085.       ((1)  (mk-code ##cprc-prc1 (body) frame))
  1086.       ((2)  (mk-code ##cprc-prc2 (body) frame))
  1087.       ((3)  (mk-code ##cprc-prc3 (body) frame))
  1088.       (else (mk-code ##cprc-prc  (body) (##fixnum.+ (##length frame) 1) frame)))))
  1089.  
  1090. (define ##cprc-prc-rest
  1091.   (mk-cprc
  1092.     (letrec ((proc
  1093.                (lambda args
  1094.                  (let ((n (^ 1)))
  1095.                    (let ((inner-rte (mk-rte* rte n)))
  1096.                      (rte-set! inner-rte 1 proc)
  1097.                      (let loop ((i 2) (l args))
  1098.                        (if (##fixnum.< i n)
  1099.                          (if (##pair? l)
  1100.                            (begin
  1101.                              (rte-set! inner-rte i (##car l))
  1102.                              (loop (##fixnum.+ i 1) (##cdr l)))
  1103.                            (rt-error-too-few-args proc args))
  1104.                          (begin
  1105.                            (rte-set! inner-rte i l)
  1106.                            (let ((rte inner-rte))
  1107.                              (code-run (^ 0)))))))))))
  1108.       proc)))
  1109.  
  1110. (define ##gen-prc-rest
  1111.   (mk-gen (frame body)
  1112.     (mk-code ##cprc-prc-rest (body) (##fixnum.+ (##length frame) 1) frame)))
  1113.  
  1114. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1115.  
  1116. (define ##cprc-app0-red
  1117.   (mk-cprc
  1118.     (let ((proc (code-run (^ 0))))
  1119.       (touch-vars (proc)
  1120.         (if (##not (##procedure? proc))
  1121.           (rt-error-non-procedure-oper $code rte)
  1122.           (##reduction-apply0 $code rte proc))))))
  1123.  
  1124. (define ##cprc-app1-red
  1125.   (mk-cprc
  1126.     (let ((proc (code-run (^ 0))))
  1127.       (touch-vars (proc)
  1128.         (if (##not (##procedure? proc))
  1129.           (rt-error-non-procedure-oper $code rte)
  1130.           (let ((arg1 (code-run (^ 1))))
  1131.             (##reduction-apply1 $code rte proc arg1)))))))
  1132.  
  1133. (define ##cprc-app2-red
  1134.   (mk-cprc
  1135.     (let ((proc (code-run (^ 0))))
  1136.       (touch-vars (proc)
  1137.         (if (##not (##procedure? proc))
  1138.           (rt-error-non-procedure-oper $code rte)
  1139.           (let ((arg1 (code-run (^ 1)))
  1140.                 (arg2 (code-run (^ 2))))
  1141.             (##reduction-apply2 $code rte proc arg1 arg2)))))))
  1142.  
  1143. (define ##cprc-app3-red
  1144.   (mk-cprc
  1145.     (let ((proc (code-run (^ 0))))
  1146.       (touch-vars (proc)
  1147.         (if (##not (##procedure? proc))
  1148.           (rt-error-non-procedure-oper $code rte)
  1149.           (let ((arg1 (code-run (^ 1)))
  1150.                 (arg2 (code-run (^ 2)))
  1151.                 (arg3 (code-run (^ 3))))
  1152.             (##reduction-apply3 $code rte proc arg1 arg2 arg3)))))))
  1153.  
  1154. (define ##cprc-app-red
  1155.   (mk-cprc
  1156.     (let ((proc (code-run (^ 0))))
  1157.       (touch-vars (proc)
  1158.         (if (##not (##procedure? proc))
  1159.           (rt-error-non-procedure-oper $code rte)
  1160.           (let loop ((i (##fixnum.- (code-length $code) 1)) (args '()))
  1161.             (if (##fixnum.< 0 i)
  1162.               (loop (##fixnum.- i 1) (##cons (code-run (code-ref $code i)) args))
  1163.               (##reduction-apply $code rte proc args))))))))
  1164.  
  1165. (define ##cprc-app0-sub
  1166.   (mk-cprc
  1167.     (let ((proc (code-run (^ 0))))
  1168.       (touch-vars (proc)
  1169.         (if (##not (##procedure? proc))
  1170.           (rt-error-non-procedure-oper $code rte)
  1171.           (##subproblem-apply0 $code rte proc))))))
  1172.  
  1173. (define ##cprc-app1-sub
  1174.   (mk-cprc
  1175.     (let ((proc (code-run (^ 0))))
  1176.       (touch-vars (proc)
  1177.         (if (##not (##procedure? proc))
  1178.           (rt-error-non-procedure-oper $code rte)
  1179.           (let ((arg1 (code-run (^ 1))))
  1180.             (##subproblem-apply1 $code rte proc arg1)))))))
  1181.  
  1182. (define ##cprc-app2-sub
  1183.   (mk-cprc
  1184.     (let ((proc (code-run (^ 0))))
  1185.       (touch-vars (proc)
  1186.         (if (##not (##procedure? proc))
  1187.           (rt-error-non-procedure-oper $code rte)
  1188.           (let ((arg1 (code-run (^ 1)))
  1189.                 (arg2 (code-run (^ 2))))
  1190.             (##subproblem-apply2 $code rte proc arg1 arg2)))))))
  1191.  
  1192. (define ##cprc-app3-sub
  1193.   (mk-cprc
  1194.     (let ((proc (code-run (^ 0))))
  1195.       (touch-vars (proc)
  1196.         (if (##not (##procedure? proc))
  1197.           (rt-error-non-procedure-oper $code rte)
  1198.           (let ((arg1 (code-run (^ 1)))
  1199.                 (arg2 (code-run (^ 2)))
  1200.                 (arg3 (code-run (^ 3))))
  1201.             (##subproblem-apply3 $code rte proc arg1 arg2 arg3)))))))
  1202.  
  1203. (define ##cprc-app-sub
  1204.   (mk-cprc
  1205.     (let ((proc (code-run (^ 0))))
  1206.       (touch-vars (proc)
  1207.         (if (##not (##procedure? proc))
  1208.           (rt-error-non-procedure-oper $code rte)
  1209.           (let loop ((i (##fixnum.- (code-length $code) 1)) (args '()))
  1210.             (if (##fixnum.< 0 i)
  1211.               (loop (##fixnum.- i 1) (##cons (code-run (code-ref $code i)) args))
  1212.               (##subproblem-apply $code rte proc args))))))))
  1213.  
  1214. (define ##gen-app
  1215.   (mk-gen (oper args)
  1216.     (case (##length args)
  1217.       ((0)  (mk-code    (if tail? ##cprc-app0-red ##cprc-app0-sub) (oper)))
  1218.       ((1)  (mk-code    (if tail? ##cprc-app1-red ##cprc-app1-sub) (oper (##car args))))
  1219.       ((2)  (mk-code    (if tail? ##cprc-app2-red ##cprc-app2-sub) (oper (##car args) (##cadr args))))
  1220.       ((3)  (mk-code    (if tail? ##cprc-app3-red ##cprc-app3-sub) (oper (##car args) (##cadr args) (##caddr args))))
  1221.       (else (##mk-code* (if tail? ##cprc-app-red  ##cprc-app-sub)  (##cons oper args) 0)))))
  1222.  
  1223. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1224.  
  1225. (define (##reduction-apply0 $code rte proc)
  1226.   (##declare (intr-checks))
  1227.   (proc))
  1228.  
  1229. (define (##reduction-apply1 $code rte proc arg1)
  1230.   (##declare (intr-checks))
  1231.   (proc arg1))
  1232.  
  1233. (define (##reduction-apply2 $code rte proc arg1 arg2)
  1234.   (##declare (intr-checks))
  1235.   (proc arg1 arg2))
  1236.  
  1237. (define (##reduction-apply3 $code rte proc arg1 arg2 arg3)
  1238.   (##declare (intr-checks))
  1239.   (proc arg1 arg2 arg3))
  1240.  
  1241. (define (##reduction-apply $code rte proc args)
  1242.   (##declare (intr-checks))
  1243.   (##apply proc args))
  1244.  
  1245. (define (##subproblem-apply0 $code rte proc)
  1246.   (##declare (intr-checks))
  1247.   (let ((result (proc)))
  1248.     (let ((a $code) (b rte))
  1249.       result)))
  1250.  
  1251. (define (##subproblem-apply1 $code rte proc arg1)
  1252.   (##declare (intr-checks))
  1253.   (let ((result (proc arg1)))
  1254.     (let ((a $code) (b rte))
  1255.       result)))
  1256.  
  1257. (define (##subproblem-apply2 $code rte proc arg1 arg2)
  1258.   (##declare (intr-checks))
  1259.   (let ((result (proc arg1 arg2)))
  1260.     (let ((a $code) (b rte))
  1261.       result)))
  1262.  
  1263. (define (##subproblem-apply3 $code rte proc arg1 arg2 arg3)
  1264.   (##declare (intr-checks))
  1265.   (let ((result (proc arg1 arg2 arg3)))
  1266.     (let ((a $code) (b rte))
  1267.       result)))
  1268.  
  1269. (define (##subproblem-apply $code rte proc args)
  1270.   (##declare (intr-checks))
  1271.   (let ((result (##apply proc args)))
  1272.     (let ((a $code) (b rte))
  1273.       result)))
  1274.  
  1275. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1276.  
  1277. (define ##cprc-delay
  1278.   (mk-cprc
  1279.     (delay (code-run (^ 0)))))
  1280.  
  1281. (define ##gen-delay
  1282.   (mk-gen (val)
  1283.     (mk-code ##cprc-delay (val))))
  1284.  
  1285. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1286.  
  1287. (define ##cprc-future
  1288.   (mk-cprc
  1289.     (future (code-run (^ 0)))))
  1290.  
  1291. (define ##gen-future
  1292.   (mk-gen (val)
  1293.     (mk-code ##cprc-future (val))))
  1294.  
  1295. ;------------------------------------------------------------------------------
  1296.  
  1297. ; Access to compiler created structures for interpreter procedures and frames
  1298.  
  1299. (define ##int-proc-body-format-1
  1300.   (##list (##proc-closure-body (##cprc-prc0 #f #f))
  1301.           (##proc-closure-body (##cprc-prc1 #f #f))
  1302.           (##proc-closure-body (##cprc-prc2 #f #f))
  1303.           (##proc-closure-body (##cprc-prc3 #f #f))))
  1304.  
  1305. (define ##int-proc-body-format-2
  1306.   (##list (##proc-closure-body (##cprc-prc       #f #f))
  1307.           (##proc-closure-body (##cprc-prc-rest  #f #f))))
  1308.  
  1309. (define (##int-proc? x)
  1310.   (and (##procedure? x)
  1311.        (##proc-closure? x)
  1312.        (or (##memq (##proc-closure-body x) ##int-proc-body-format-1)
  1313.            (##memq (##proc-closure-body x) ##int-proc-body-format-2))))
  1314.  
  1315. (define (##int-proc-code x)
  1316.   (if (##memq (##proc-closure-body x) ##int-proc-body-format-1)
  1317.     (##proc-closure-ref x 0)
  1318.     (##proc-closure-ref x 2)))
  1319.  
  1320. (define (##int-proc-rte x)
  1321.   (if (##memq (##proc-closure-body x) ##int-proc-body-format-1)
  1322.     (##proc-closure-ref x 2)
  1323.     (##proc-closure-ref x 1)))
  1324.  
  1325. ;==============================================================================
  1326.  
  1327. ; Eval
  1328.  
  1329. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1330.  
  1331. ; Evaluation in the global environment (with current dynamic env)
  1332.  
  1333. (define ##eval-global #f)
  1334. (set! ##eval-global
  1335.   (lambda (expr)
  1336.     (##eval expr #f #f (##dynamic-env-ref))))
  1337.  
  1338. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1339.  
  1340. ; Evaluation in a particular environment ('frames' describes the runtime
  1341. ; environment 'rte').
  1342.  
  1343. (define ##eval #f)
  1344. (set! ##eval
  1345.   (lambda (expr frames rte dyn-env)
  1346.     (let ((c (##compile expr frames)))
  1347.       (##dynamic-env-bind
  1348.         dyn-env
  1349.         (lambda () (let ((rte rte)) (code-run c)))))))
  1350.  
  1351. ;==============================================================================
  1352.  
  1353. ; Decompilation of a piece of code
  1354.  
  1355. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1356.  
  1357. (##define-macro (mk-degen params . def)
  1358.   `(lambda ($code ,@params) ,@def))
  1359.  
  1360. (##define-macro (degen proc . args)
  1361.   `(,proc $code ,@args))
  1362.  
  1363. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1364.  
  1365. (define (##extract-frame subcode up)
  1366.   (let (($code (code-link subcode)))
  1367.     (if $code
  1368.       (let ((cprc (code-cprc $code)))
  1369.         (cond ((##eq? cprc ##cprc-top)
  1370.                (##extract-frame-top $code subcode up))
  1371.               ((##eq? cprc ##cprc-glo-def)
  1372.                (##extract-frame-glo-def $code subcode up))
  1373.               ((##eq? cprc ##cprc-case)
  1374.                (##extract-frame-case $code subcode up))
  1375.               ((##eq? cprc ##cprc-let)
  1376.                (##extract-frame-let $code subcode up))
  1377.               ((##eq? cprc ##cprc-letrec)
  1378.                (##extract-frame-letrec $code subcode up))
  1379.               ((or (##eq? cprc ##cprc-prc0)
  1380.                    (##eq? cprc ##cprc-prc1)
  1381.                    (##eq? cprc ##cprc-prc2)
  1382.                    (##eq? cprc ##cprc-prc3)
  1383.                    (##eq? cprc ##cprc-prc)
  1384.                    (##eq? cprc ##cprc-prc-rest))
  1385.                (##extract-frame-prc $code subcode up))
  1386.               (else
  1387.                (##extract-frame-default $code subcode up))))
  1388.       #f)))
  1389.  
  1390. (define ##extract-frame-default
  1391.   (lambda ($code subcode up)
  1392.     (##extract-frame $code up)))
  1393.  
  1394. (define ##extract-frame-top
  1395.   (lambda ($code subcode up)
  1396.     (if (##fixnum.= up 0)
  1397.       (##list (self-var))
  1398.       (let loop ((frames (^ 1)) (up (##fixnum.- up 1)))
  1399.         (if frames
  1400.           (if (##fixnum.= up 0)
  1401.             (##car frames)
  1402.             (loop (##cdr frames) (##fixnum.- up 1)))
  1403.           #f)))))
  1404.  
  1405. (define ##extract-frame-glo-def
  1406.   (lambda ($code subcode up)
  1407.     #f))
  1408.  
  1409. (define ##extract-frame-case
  1410.   (lambda ($code subcode up)
  1411.     (if (##eq? subcode (^ 1))
  1412.       (if (##fixnum.= up 0)
  1413.         (##list (selector-var))
  1414.         (##extract-frame $code (##fixnum.- up 1)))
  1415.       (##extract-frame $code up))))
  1416.  
  1417. (define ##extract-frame-let
  1418.   (lambda ($code subcode up)
  1419.     (if (##eq? subcode (^ 0))
  1420.       (if (##fixnum.= up 0)
  1421.         (code-ref $code (##fixnum.- (code-length $code) 1))
  1422.         (##extract-frame $code (##fixnum.- up 1)))
  1423.       (##extract-frame $code up))))
  1424.  
  1425. (define ##extract-frame-letrec
  1426.   (lambda ($code subcode up)
  1427.     (if (##fixnum.= up 0)
  1428.       (code-ref $code (##fixnum.- (code-length $code) 1))
  1429.       (##extract-frame $code (##fixnum.- up 1)))))
  1430.  
  1431. (define ##extract-frame-prc
  1432.   (lambda ($code subcode up)
  1433.     (if (##fixnum.= up 0)
  1434.       (##cons (self-var) (code-ref $code (##fixnum.- (code-length $code) 1)))
  1435.       (##extract-frame $code (##fixnum.- up 1)))))
  1436.  
  1437. (define (##extract-frames $code)
  1438.  
  1439.   (define (rev l tail)
  1440.     (if (##pair? l) (rev (##cdr l) (##cons (##car l) tail)) tail))
  1441.  
  1442.   (let loop ((i 0) (frames '()))
  1443.     (let ((frame (##extract-frame $code i)))
  1444.       (if frame
  1445.         (loop (##fixnum.+ i 1) (##cons frame frames))
  1446.         (rev frames #f)))))
  1447.  
  1448. (define (##extract-proc $code rte)
  1449.   (let loop ((i 0) (rte rte))
  1450.     (let ((frame (##extract-frame $code i)))
  1451.       (if frame
  1452.         (if (and (##pair? frame) (##eq? (##car frame) (self-var)))
  1453.           (rte-ref rte 1)
  1454.           (loop (##fixnum.+ i 1) (rte-up rte)))
  1455.         #f))))
  1456.  
  1457. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1458.  
  1459. (define (##BEGIN? x) (and (##pair? x) (##eq? (##car x) 'BEGIN)))
  1460. (define (##COND? x)  (and (##pair? x) (##eq? (##car x) 'COND)))
  1461. (define (##AND? x)   (and (##pair? x) (##eq? (##car x) 'AND)))
  1462. (define (##OR? x)    (and (##pair? x) (##eq? (##car x) 'OR)))
  1463. (define (##unspecified-obj? x)
  1464.   (and (##pa   (##list (if (##BEGIN? val)
  1465.                   (##cons 'ELSE (##cdr val))
  1466.                   (##list 'ELSE val)))))))
  1467.  
  1468. (define ##degen-let
  1469.   (mk-degen ()
  1470.     (let ((n (code-length $code)))
  1471.       (let loop ((i (##fixnum.- n 2)) (vals '()))
  1472.         (if (##fixnum.< 0 i)
  1473.           (loop (##fixnum.- i 1)
  1474.                 (##cons (##decomp (code-ref $code i)) vals))
  1475.           (let ((body (##decomp (^ 0)))
  1476.                 (bindings (##make-bindings (code-ref $code (##fixnum.- n 1)) vals)))
  1477.             (if (##BEGIN? body)
  1478.               (##cons 'LET (##cons bindings (##cdr body)))
  1479.               (##list 'LET bindings body))))))))
  1480.  
  1481. (define (##make-bindings l1 l2)
  1482.   (if (##pair? l1)
  1483.     (##cons (##list (##car l1) (##car l2))
  1484.             (##make-bindings (##cdr l1) (##cdr l2)))
  1485.     '()))
  1486.  
  1487. (define ##degen-letrec
  1488.   (mk-degen ()
  1489.     (let ((n (code-length $code)))
  1490.       (let loop ((i (##fixnum.- n 2)) (vals '()))
  1491.         (if (##fixnum.< 0 i)
  1492.           (loop (##fixnum.- i 1)
  1493.                 (##cons (##decomp (code-ref $code i)) vals))
  1494.           (let ((body (##decomp (^ 0)))
  1495.                 (bindings (##make-bindings (code-ref $code (##fixnum.- n 1)) vals)))
  1496.             (if (##BEGIN? body)
  1497.               (##cons 'LETREC (##cons bindings (##cdr body)))
  1498.               (##list 'LETREC bindings body))))))))
  1499.  
  1500. (define ##degen-prc
  1501.   (mk-degen ()
  1502.     (let ((body (##decomp (^ 0)))
  1503.           (params (code-ref $code (##fixnum.- (code-length $code) 1))))
  1504.       (if (##BEGIN? body)
  1505.         (##cons 'LAMBDA (##cons params (##cdr body)))
  1506.         (##list 'LAMBDA params body)))))
  1507.  
  1508. (define ##degen-prc-rest
  1509.   (mk-degen ()
  1510.     (let ((body (##decomp (^ 0)))
  1511.           (params (##make-rest-params (^ 2))))
  1512.       (if (##BEGIN? body)
  1513.         (##cons 'LAMBDA (##cons params (##cdr body)))
  1514.         (##list 'LAMBDA params body)))))
  1515.  
  1516. (define (##make-rest-params l)
  1517.   (if (##null? (##cdr l))
  1518.     (##car l)
  1519.     (##cons (##car l) (##make-rest-params (##cdr l)))))
  1520.  
  1521. (define ##degen-app0
  1522.   (mk-degen ()
  1523.     (##list (##decomp (^ 0)))))
  1524.  
  1525. (define ##degen-app1
  1526.   (mk-degen ()
  1527.     (##list (##decomp (^ 0))
  1528.             (##decomp (^ 1)))))
  1529.  
  1530. (define ##degen-app2
  1531.   (mk-degen ()
  1532.     (##list (##decomp (^ 0))
  1533.             (##decomp (^ 1))
  1534.             (##decomp (^ 2)))))
  1535.  
  1536. (define ##degen-app3
  1537.   (mk-degen ()
  1538.     (##list (##decomp (^ 0))
  1539.             (##decomp (^ 1))
  1540.             (##decomp (^ 2))
  1541.             (##decomp (^ 3)))))
  1542.  
  1543. (define ##degen-app
  1544.   (mk-degen ()
  1545.     (let ((n (code-length $code)))
  1546.       (let loop ((i (##fixnum.- n 1)) (vals '()))
  1547.         (if (##not (##fixnum.< i 0))
  1548.           (loop (##fixnum.- i 1)
  1549.                 (##cons (##decomp (code-ref $code i)) vals))
  1550.           vals)))))
  1551.  
  1552. (define ##degen-delay
  1553.   (mk-degen ()
  1554.     (##list 'DELAY (##decomp (^ 0)))))
  1555.  
  1556. (define ##degen-future
  1557.   (mk-degen ()
  1558.     (##list 'FUTURE (##decomp (^ 0)))))
  1559.  
  1560. ;------------------------------------------------------------------------------
  1561.  
  1562. (define ##decomp-dispatch-table
  1563.   (##list
  1564.     (##cons ##cprc-top           ##degen-top)
  1565.  
  1566.     (##cons ##cprc-cst-null      (mk-degen () (degen ##degen-cst-x '())))
  1567.     (##cons ##cprc-cst-true      (mk-degen () (degen ##degen-cst-x #t)))
  1568.     (##cons ##cprc-cst-false     (mk-degen () (degen ##degen-cst-x #f)))
  1569.     (##cons ##cprc-cst--2        (mk-degen () (degen ##degen-cst-x -2)))
  1570.     (##cons ##cprc-cst--1        (mk-degen () (degen ##degen-cst-x -1)))
  1571.     (##cons ##cprc-cst-0         (mk-degen () (degen ##degen-cst-x 0)))
  1572.     (##cons ##cprc-cst-1         (mk-degen () (degen ##degen-cst-x 1)))
  1573.     (##cons ##cprc-cst-2         (mk-degen () (degen ##degen-cst-x 2)))
  1574.     (##cons ##cprc-cst           ##degen-cst)
  1575.  
  1576.     (##cons ##cprc-loc-ref-0-1   (mk-degen () (degen ##degen-loc-ref-x-y 0 1)))
  1577.     (##cons ##cprc-loc-ref-0-2   (mk-degen () (degen ##degen-loc-ref-x-y 0 2)))
  1578.     (##cons ##cprc-loc-ref-0-3   (mk-degen () (degen ##degen-loc-ref-x-y 0 3)))
  1579.     (##cons ##cprc-loc-ref-1-1   (mk-degen () (degen ##degen-loc-ref-x-y 1 1)))
  1580.     (##cons ##cprc-loc-ref-1-2   (mk-degen () (degen ##degen-loc-ref-x-y 1 2)))
  1581.     (##cons ##cprc-loc-ref-1-3   (mk-degen () (degen ##degen-loc-ref-x-y 1 3)))
  1582.     (##cons ##cprc-loc-ref-2-1   (mk-degen () (degen ##degen-loc-ref-x-y 2 1)))
  1583.     (##cons ##cprc-loc-ref-2-2   (mk-degen () (degen ##degen-loc-ref-x-y 2 2)))
  1584.     (##cons ##cprc-loc-ref-2-3   (mk-degen () (degen ##degen-loc-ref-x-y 2 3)))
  1585.     (##cons ##cprc-loc-ref       ##degen-loc-ref)
  1586.     (##cons ##cprc-glo-ref       ##degen-glo-ref)
  1587.  
  1588.     (##cons ##cprc-loc-set       ##degen-loc-set)
  1589.     (##cons ##cprc-glo-set       ##degen-glo-set)
  1590.     (##cons ##cprc-glo-def       ##degen-glo-def)
  1591.  
  1592.     (##cons ##cprc-if2           ##degen-if2)
  1593.     (##cons ##cprc-if3           ##degen-if3)
  1594.     (##cons ##cprc-seq           ##degen-seq)
  1595.     (##cons ##cprc-quasi-list->vector ##degen-quasi-list->vector)
  1596.     (##cons ##cprc-quasi-append  ##degen-quasi-append)
  1597.     (##cons ##cprc-quasi-cons    ##degen-quasi-cons)
  1598.     (##cons ##cprc-cond-if       ##degen-cond-if)
  1599.     (##cons ##cprc-cond-or       ##degen-cond-or)
  1600.     (##cons ##cprc-cond-send-red ##degen-cond-send)
  1601.     (##cons ##cprc-cond-send-sub ##degen-cond-send)
  1602.  
  1603.     (##cons ##cprc-or            ##degen-or)
  1604.     (##cons ##cprc-and           ##degen-and)
  1605.  
  1606.     (##cons ##cprc-case          ##degen-case)
  1607.     (##cons ##cprc-case-clause   ##degen-case-clause)
  1608.     (##cons ##cprc-case-else     ##degen-case-else)
  1609.  
  1610.     (##cons ##cprc-let           ##degen-let)
  1611.     (##cons ##cprc-letrec        ##degen-letrec)
  1612.  
  1613.     (##cons ##cprc-prc0          ##degen-prc)
  1614.     (##cons ##cprc-prc1          ##degen-prc)
  1615.     (##cons ##cprc-prc2          ##degen-prc)
  1616.     (##cons ##cprc-prc3          ##degen-prc)
  1617.     (##cons ##cprc-prc           ##degen-prc)
  1618.     (##cons ##cprc-prc-rest      ##degen-prc-rest)
  1619.  
  1620.     (##cons ##cprc-app0-red      ##degen-app0)
  1621.     (##cons ##cprc-app1-red      ##degen-app1)
  1622.     (##cons ##cprc-app2-red      ##degen-app2)
  1623.     (##cons ##cprc-app3-red      ##degen-app3)
  1624.     (##cons ##cprc-app-red       ##degen-app)
  1625.     (##cons ##cprc-app0-sub      ##degen-app0)
  1626.     (##cons ##cprc-app1-sub      ##degen-app1)
  1627.     (##cons ##cprc-app2-sub      ##degen-app2)
  1628.     (##cons ##cprc-app3-sub      ##degen-app3)
  1629.     (##cons ##cprc-app-sub       ##degen-app)
  1630.  
  1631.     (##cons ##cprc-delay         ##degen-delay)
  1632.     (##cons ##cprc-future        ##degen-future)
  1633. ))
  1634.  
  1635. ;------------------------------------------------------------------------------
  1636.  
  1637. (define (##decomp $code)
  1638.   (let ((cprc (code-cprc $code)))
  1639.     (let ((x (##assq cprc ##decomp-dispatch-table)))
  1640.       (if x
  1641.         (degen (##cdr x))
  1642.         '?))))
  1643.  
  1644. (define (##decompile proc)
  1645.  
  1646.   (define (decomp1 p)
  1647.     (if (##proc-subproc? p)
  1648.       (decomp2 (##proc-subproc-parent p) (##proc-subproc-tag p))
  1649.       (decomp2 p 0)))
  1650.  
  1651.   (define (decomp2 parent tag)
  1652.     (let ((info (##proc-debug-info parent)))
  1653.       (if info
  1654.         (let ((v (##vector-ref info 0)))
  1655.           (let loop ((i (##fixnum.- (##vector-length v) 1)))
  1656.             (if (##fixnum.< i 0)
  1657.               proc
  1658.               (let ((x (##vector-ref v i)))
  1659.                 (if (##fixnum.= tag (##vector-ref x 0))
  1660.                   (source->expression (##vector-ref x 1))
  1661.                   (loop (##fixnum.- i 1)))))))
  1662.         proc)))
  1663.  
  1664.   (define (source-code x)
  1665.     (##vector-ref x 0))
  1666.  
  1667.   (define (source->expression source)
  1668.  
  1669.     (define (list->expression l)
  1670.       (cond ((##pair? l)
  1671.              (##cons (source->expression (##car l))
  1672.                      (list->expression (##cdr l))))
  1673.             ((##null? l)
  1674.              '())
  1675.             (else
  1676.              (source->expression l))))
  1677.  
  1678.     (define (vector->expression v)
  1679.       (let* ((len (##vector-length v))
  1680.              (x (##make-vector len #f)))
  1681.         (let loop ((i (##fixnum.- len 1)))
  1682.           (if (##not (##fixnum.< i 0))
  1683.             (begin
  1684.               (##vector-set! x i (source->expression (##vector-ref v i)))
  1685.               (loop (##fixnum.- i 1)))))
  1686.         x))
  1687.  
  1688.     (let ((code (source-code source)))
  1689.       (cond ((##pair? code)   (list->expression code))
  1690.             ((##vector? code) (vector->expression code))
  1691.             (else             code))))
  1692.  
  1693.   (cond ((##int-proc? proc)
  1694.          (##decomp (##int-proc-code proc)))
  1695.         ((##proc-closure? proc)
  1696.          (decomp1 (##p
  1697.                      (##eq? (##car expr) 'UNQUOTE))
  1698.               (let ((cmd (##cadr expr)))
  1699.                 (if (##eof-object? cmd)
  1700.                   (begin (cmd-d) (loop))
  1701.                   (case cmd
  1702.                     ((?) (##cmd-? out) (loop))
  1703.                     ((-) (repl-n (##fixnum.- pos 1)))
  1704.                     ((+) (repl-n (##fixnum.+ pos 1)))
  1705.                     ((b) (##cmd-b pos subprobs* out) (loop))
  1706.                     ((i) (##cmd-i f out) (loop))
  1707.                     ((y) (##cmd-y f out) (loop))
  1708.                     ((l) (##cmd-l f out) (loop))
  1709.                     ((t) (cmd-t))
  1710.                     ((d) (cmd-d) (loop))
  1711.                     ((r) (##display "Return value: " out #f)
  1712.                          (let ((expr (repl-read)))
  1713.                            (if (##eof-object? expr)
  1714.                              ##undef-object
  1715.                              (##eval-within expr f dyn-bindings))))
  1716.                     ((q) (##quit))
  1717.                     (else
  1718.                      (if (and (##fixnum? cmd) (##fixnum.< cmd 1))
  1719.                        (repl-n cmd)
  1720.                        (begin
  1721.                          (##write-string "Unknown command ," out)
  1722.                          (##write cmd out #f)
  1723.                          (##newline out)
  1724.                          (loop)))))))
  1725.             (let ((val (##eval-within expr f dyn-bindings)))
  1726.               (repl-write val)
  1727.               (loop)))))))
  1728.  
  1729.     (repl 0 subprobs (##car subprobs)))
  1730.  
  1731.   (let ((repl-info (##make-vector 4 #f)))
  1732.     (let ((prev-info (##dynamic-ref '##REPL-INFO #f))
  1733.           (dyn-bindings (##list (##cons '##REPL-INFO repl-info))))
  1734.       (##vector-set! repl-info 0 in)
  1735.       (##vector-set! repl-info 1 out)
  1736.       (##vector-set! repl-info 2
  1737.         (if prev-info
  1738.           (##fixnum.+ (##vector-ref prev-info 2) 1)
  1739.           0))
  1740.       (##vector-set! repl-info 3
  1741.         (##cons (lambda (x) (##quit))
  1742.                 (if prev-info
  1743.                   (##vector-ref prev-info 3)
  1744.                   '())))
  1745.       (##dynamic-bind
  1746.         dyn-bindings
  1747.         (lambda ()
  1748.           (repl-start (##continuation->subproblems cont)
  1749.                       repl-info
  1750.                       dyn-bindings))))))
  1751.  
  1752. (define (##repl-out)
  1753.   (let ((repl-info (##dynamic-ref '##REPL-INFO #f)))
  1754.     (if repl-info
  1755.       (##vector-ref repl-info 1)
  1756.       ##stdout)))
  1757.  
  1758. (define (##debug-repl cont)
  1759.   (let ((repl-info (##dynamic-ref '##REPL-INFO #f)))
  1760.     (if repl-info
  1761.       (##read-eval-print (##vector-ref repl-info 0)
  1762.                          (##vector-ref repl-info 1)
  1763.                          ": "
  1764.                          (##fixnum.+ (##vector-ref repl-info 2) 1)
  1765.                          cont)
  1766.       (##read-eval-print ##stdin ##stdout ": " 0 cont))))
  1767.  
  1768. (define (##pop-repl)
  1769.   (let ((repl-info (##dynamic-ref '##REPL-INFO #f)))
  1770.     (if repl-info
  1771.       ((##car (##vector-ref repl-info 3)) #f)
  1772.       (##quit))))
  1773.  
  1774. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1775.  
  1776. (define (##cmd-? out)
  1777.   (##write-string ",?        : Summary of commands" out) (##newline out)
  1778.   (##write-string ",+ and ,- : Move to next or previous frame of continuation" out) (##newline out)
  1779.   (##write-string ",<n>      : Move to particular frame (<n> <= 0)" out) (##newline out)
  1780.   (##write-string ",b        : Display frames of continuation (i.e. backtrace)" out) (##newline out)
  1781.   (##write-string ",i        : Display procedure attached to current frame" out) (##newline out)
  1782.   (##write-string ",y        : Display subproblem of current frame" out) (##newline out)
  1783.   (##write-string ",l        : Display list of local variables accessible in current frame" out) (##newline out)
  1784.   (##write-string ",t        : Transfer to top-level REP loop" out) (##newline out)
  1785.   (##write-string ",d        : Transfer to previous REP loop" out) (##newline out)
  1786.   (##write-string ",r        : Return from REP loop" out) (##newline out)
  1787.   (##write-string ",q        : Quit" out) (##newline out))
  1788.  
  1789. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1790.  
  1791. (define (##cmd-b pos subprobs* out)
  1792.   (define max-head 10)
  1793.   (define max-tail 6)
  1794.   (let loop ((i 0) (j (##fixnum.- (##length subprobs*) 1)) (l subprobs*))
  1795.     (if (##pair? l)
  1796.       (begin
  1797.         (cond ((or (##fixnum.< i max-head) (##fixnum.< j max-tail)
  1798.                    (and (##fixnum.= i max-head) (##fixnum.= j max-tail)))
  1799.                (##display-subproblem (##fixnum.- pos i) (##car l) out))
  1800.               ((##fixnum.= i max-head)
  1801.                (##write-string "..." out) (##newline out)))
  1802.         (loop (##fixnum.+ i 1) (##fixnum.- j 1) (##cdr l))))))
  1803.  
  1804. (define (##display-subproblem pos f out)
  1805.   (let ((x (##write pos out #f)))
  1806.     (##display-spaces (##fixnum.- 4 x) out)
  1807.     (##write-string " " out)
  1808.  
  1809.     (if (##int-frame-subproblem? f)
  1810.  
  1811.       (let ((code (##int-frame-subproblem-code f))
  1812.             (rte (##int-frame-subproblem-rte f)))
  1813.         (let ((proc (##extract-proc code rte)))
  1814.           (let ((x (if proc
  1815.                      (##write (##procedure-name proc) out #f)
  1816.                      (##display "(top level)" out #f))))
  1817.             (##display-spaces (##fixnum.- 25 x) out)
  1818.             (##write-string " " out)
  1819.             (##write-string (##object->string (##decomp code) 48 #f) out)
  1820.             (##newline out))))
  1821.  
  1822.       (let ((parent (##proc-subproc-parent (##frame-ret f))))
  1823.         (let ((x (##write (##procedure-name parent) out #f)))
  1824.           (let ((y (##decompile (##frame-ret f))))
  1825.             (if (##not (##eq? y (##frame-ret f)))
  1826.               (begin
  1827.                 (##display-spaces (##fixnum.- 25 x) out)
  1828.                 (##write-string " " out)
  1829.                 (##write-string (##object->string y 48 #f) out)))
  1830.             (##newline out)))))))
  1831.  
  1832. (define (##display-spaces n out)
  1833.   (if (##fixnum.< 0 n)
  1834.     (let ((m (if (##fixnum.< 40 n) 40 n)))
  1835.       (##write-substring "                                        " 0 m out)
  1836.       (##display-spaces (##fixnum.- n m) out))))
  1837.  
  1838. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1839.  
  1840. (define (##cmd-l f out)
  1841.  
  1842.   (define (display-locals frames rte)
  1843.     (let loop1 ((l frames) (r rte))
  1844.       (if (##pair? l)
  1845.         (let loop2 ((frame (##car l)) (values (##cdr (##vector->list r))))
  1846.           (if (##pair? frame)
  1847.             (let ((var (##car frame)))
  1848.               (if (##not (or (##eq? var (self-var))
  1849.                              (##eq? var (selector-var))
  1850.                              (##eq? var (do-loop-var))))
  1851.                 (let ((x (##write var out #f)))
  1852.                   (##write-string " = " out)
  1853.                   (##write-string (##object->string
  1854.                                     (##car values)
  1855.                                     (##fixnum.- (##fixnum.- (##port-width out) 3) x)
  1856.                                     (if-touches #t #f))
  1857.                                   out)
  1858.                   (##newline out)))
  1859.               (loop2 (##cdr frame) (##cdr values)))
  1860.             (loop1 (##cdr l) (rte-up r)))))))
  1861.  
  1862.   (if (##int-frame-subproblem? f)
  1863.     (display-locals (##extract-frames (##int-frame-subproblem-code f))
  1864.                     (##int-frame-subproblem-rte f))
  1865.     (begin
  1866.       (##write-string "Sorry, can't display compiled code environment" out)
  1867.       (##newline out))))
  1868.  
  1869. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1870.  
  1871. (define (##cmd-y f out)
  1872.   (if (##int-frame-subproblem? f)
  1873.     (##pretty-print (##decomp (##int-frame-subproblem-code f)) out (##port-width out))
  1874.     (let ((x (##decompile (##frame-ret f))))
  1875.       (if (##eq? x (##frame-ret f))
  1876.         (begin
  1877.           (##write-string "Sorry, this code was compiled without the DEBUG option" out)
  1878.           (##newline out))
  1879.         (##pretty-print x out (##port-width out))))))
  1880.  
  1881. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1882.  
  1883. (define (##cmd-i f out)
  1884.   (if (##int-frame-subproblem? f)
  1885.  
  1886.     (let ((code (##int-frame-subproblem-code f))
  1887.           (rte (##int-frame-subproblem-rte f)))
  1888.       (let ((proc (##extract-proc code rte)))
  1889.         (if proc
  1890.           (begin
  1891.             (##write proc out #f)
  1892.             (##write-string " =" out)
  1893.             (##newline out)
  1894.             (##pretty-print (##decompile proc) out (##port-width out)))
  1895.           (begin
  1896.             (##write-string "(top level)" out)
  1897.             (##newline out)))))
  1898.  
  1899.     (let ((proc (##proc-subproc-parent (##frame-ret f))))
  1900.       (##write proc out #f)
  1901.       (let ((x (##decompile proc)))
  1902.         (if (##eq? x proc)
  1903.           (##newline out)
  1904.           (begin
  1905.             (##write-string " =" out)
  1906.             (##newline out)
  1907.             (##pretty-print x out (##port-width out))))))))
  1908.  
  1909. ;==============================================================================
  1910.